10 ' stamping.bas - FreeWare 2005
20 GOTO 120 ' begin
30 SAVE"stamping.bas",A:LIST-120
40 GOTO 590  ' wait for key
50 GOTO 620  ' centered text
60 GOTO 720  ' graphics 1
70 GOTO 840  ' graphics 2
80 GOTO 890  ' graphics 3
90 GOTO 1170 ' graphics 4
100 GOTO 1300 ' graphics 5
110 ' begin
120 DEFSTR M,Q:Q=MKI$(0):SCREEN  9:CLS
130 DIM X(4,6),Y(4,6):E(1)=3:E(2)=3:E(3)=4:E(4)=6
140 DATA 1,-3,1,-1,3,-1,1,3,1,1,3,1
150 DATA -3,-1,-1,-1,-1,1,-3,1,-1,-3,-1,-2,0,-2,0,2,-1,2,-1,3
160 FOR K=1 TO 4
170  FOR L=1 TO E(K)
180   READ X(K,L),Y(K,L)
190  NEXT
200 NEXT
210 M(1)="STAMPS & TRUCHET idea from Hans Lauwerier"
220 M(2)="GWBasic by Eric Tchong"
230 M(3)="Press any key to return to this screen"
240 M(4)="Choose 1..3   -1 = stop program "
250 M(5)="tile in normal phase"
260 M(6)="Assemble a number from 1,2,3,4"
270 M(7)="Choose 1..4  < 0 to menu>"
280 FOR I=1 TO 4
290  GOSUB 50:IF I=2 OR I=3 THEN PRINT
300 NEXT
310 LOCATE 7,29:INPUT CH
320 IF CH=-1 THEN SCREEN 0,0,0:CLS:END
330 IF CH<1 OR CH>3 THEN 310
340 CLS:ON CH GOTO 360,650,940
350 ' tile in normal phase
360 I=5:GOSUB 50
370 WINDOW (-8,-6)-(8,6)
380 FOR I=-3 TO 3:LINE (I,-3)-(I,3),4:NEXT
390 FOR J=-3 TO 3:LINE (-3,J)-(3,J),4:NEXT
400 FOR K=1 TO 4
410  PSET (X(K,1),Y(K,1))
420  FOR L=2 TO E(K)
430   LINE -(X(K,L),Y(K,L))
440  NEXT
450 NEXT:A$=INPUT$(1):CLS
460 ' other tiles
470 WINDOW (-18,-16)-(110,80)
480 I=7:GOSUB 50
490 LOCATE 2,33:INPUT CH
500 IF CH=0 THEN CLS:GOTO 280
510 IF CH<1 OR CH>4 THEN 490
520 CLS:ON CH GOTO 530,540,550,560
530 S(0)=0:S(1)=0:S(2)=0:S(3)=0:CLS:PRINT"0 0 0 0":GOTO 570
540 S(0)=1:S(1)=2:S(2)=3:S(3)=4:CLS:PRINT"1 2 3 4":GOTO 570
550 S(0)=4:S(1)=3:S(2)=2:S(3)=1:CLS:PRINT"4 3 2 1":GOTO 570
560 S(0)=3:S(1)=2:S(2)=4:S(3)=1:CLS:PRINT"3 2 4 1":GOTO 570
570 LINE (-3,-3)-(93,69),,B:GOSUB 60:GOSUB 40:CLS:GOTO 480
580 ' wait for key
590 LSET Q=MKI$(0)
600 WHILE CVI(Q)=0:MID$(Q,1)=INKEY$:WEND:RETURN
610 ' centered text
620 X=(80-LEN(M(I)))/2
630 PRINT TAB(X) M(I):RETURN
640 ' stampx
650 WINDOW (-18,-16)-(110,80)
660 LINE (-3,-3)-(93,69),,B
670 LINE (-5,-5)-(95,71),,B
680 S(0)=3:S(1)=2:S(2)=4:S(3)=1:GOSUB 60
690 PAINT (3,3)
700 GOSUB 40:CLS:GOTO 280
710 ' graphics 1
720 FOR J=0 TO 11
730  FOR I=0 TO 15
740   X=6*I:Y=6*J
750   IF J MOD 2=0 THEN W=0 ELSE W=2
760   IF I MOD 2=1 THEN W=W+1
770   S=S(W)
780   IF S=1 OR S=2 THEN P=1 ELSE P=-1
790   IF S=1 OR S=4 THEN R=1 ELSE R=-1
800   IF S=1 OR S=3 THEN GOSUB 70 ELSE GOSUB 80
810  NEXT
820 NEXT:RETURN
830 ' graphics 2
840 FOR K=1 TO 4
850  PSET (X+P*X(K,1),Y+R*Y(K,1))      ' x x y y
860  FOR L=2 TO E(K):LINE -(X+P*X(K,L),Y+R*Y(K,L)):NEXT
870 NEXT:RETURN
880 ' graphics 3
890 FOR K=1 TO 4
900  PSET (X+P*Y(K,1),Y+R*X(K,1))      ' x y y x
910  FOR L=2 TO E(K):LINE -(X+P*Y(K,L),Y+R*X(K,L)):NEXT
920 NEXT:RETURN
930 ' truchet
940 CLS:PI=4*ATN(1):WINDOW (-320,-240)-(319,239)
950 RANDOMIZE 222
960 R=10:N=10:P=2*N*R
970 LINE (-P,-P)-(P,P),,B
980 FOR I=-N TO N-1
990  FOR J=-N TO N-1
1000   X0=2*R*I+R:Y0=2*R*J+R
1010   IF RND<.5 THEN GOSUB 90 ELSE GOSUB 100
1020  NEXT
1030 NEXT:GOSUB 40 ' pause
1040 FOR I=-N TO N
1050  FOR J=-N TO N
1060   IF (I+J) MOD 2 = 0 THEN 1130
1070   X=2*R*I:Y=2*R*J
1080   IF I=-N THEN X=X+1
1090   IF I=N THEN X=X-1
1100   IF J=-N THEN Y=Y+1
1110   IF J=N THEN Y=Y-1
1120   PAINT (X,Y)
1130  NEXT
1140 NEXT
1150 GOSUB 40:CLS:GOTO 280
1160 ' graphics 4
1170 X=X0-R:Y=Y0-R
1180 FOR K=0 TO 9
1190  T=K*10*PI/180
1200  U=X+R*COS(T):V=Y+R*SIN(T)
1210  IF K=0 THEN PSET (U,V) ELSE LINE -(U,V)
1220 NEXT
1230 X=X0+R:Y=Y0+R
1240 FOR K=0 TO 9
1250  T=(180+K*10)*PI/180
1260  U=X+R*COS(T):V=Y+R*SIN(T)
1270  IF K=0 THEN PSET (U,V) ELSE LINE -(U,V)
1280 NEXT:RETURN
1290 ' graphics 5
1300 X=X0+R:Y=Y0-R
1310 FOR K=0 TO 9
1320  T=(90+K*10)*PI/180
1330  U=X+R*COS(T):V=Y+R*SIN(T)
1340  IF K=0 THEN PSET (U,V) ELSE LINE -(U,V)
1350 NEXT
1360 X=X0-R:Y=Y0+R
1370 FOR K=0 TO 9
1380  T=(270+K*10)*PI/180
1390  U=X+R*COS(T):V=Y+R*SIN(T)
1400  IF K=0 THEN PSET (U,V) ELSE LINE -(U,V)
1410 NEXT:RETURN
